home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / parser.y < prev    next >
Encoding:
Text File  |  1993-08-25  |  28.3 KB  |  819 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * parser.y:    Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  *              You should expect 14 shift/reduce conflicts when passing
  7.  *              this grammar through yacc.  Don't worry, they will all be
  8.  *              resolved correctly as shifts.
  9.  *
  10.  *        There will also be 5 reduce/reduce conflicts.  These are
  11.  *        more worrying although they will still be resolved correctly
  12.  *        as long as you keep the two grammar rules concerned (see the
  13.  *        y.output file for details) in the same order as used here.
  14.  *
  15.  * Gofer parser (included as part of input.c)
  16.  * ------------------------------------------------------------------------*/
  17.  
  18. %{
  19. #ifndef lint
  20. #define lint
  21. #endif
  22. #define defTycon(n,l,lhs,rhs,w)     tyconDefn(intOf(l),lhs,rhs,w); sp-=n
  23. #define sigdecl(l,vs,t)         ap(SIGDECL,triple(l,vs,t))
  24. #define grded(gs)         ap(GUARDED,gs)
  25. #define letrec(bs,e)         (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
  26. #define yyerror(s)         /* errors handled elsewhere */
  27. #define YYSTYPE             Cell
  28.  
  29. static Cell   local gcShadow     Args((Int,Cell));
  30. static Void   local syntaxError  Args((String));
  31. static String local unexpected   Args((Void));
  32. static Cell   local checkPrec    Args((Cell));
  33. static Void   local fixDefn      Args((Syntax,Cell,Cell,List));
  34. static Void   local setSyntax    Args((Int,Syntax,Cell));
  35. #if MAC
  36.        Cell   local buildTuple   Args((List));
  37. #else
  38. static Cell   local buildTuple   Args((List));
  39. #endif
  40. static Cell   local checkClass   Args((Cell));
  41. static List   local checkContext Args((List));
  42. static Cell   local tidyInfix    Args((Cell));
  43.  
  44. /* For the purposes of reasonably portable garbage collection, it is
  45.  * necessary to simulate the YACC stack on the Gofer stack to keep
  46.  * track of all intermediate constructs.  The lexical analyser
  47.  * pushes a token onto the stack for each token that is found, with
  48.  * these elements being removed as reduce actions are performed,
  49.  * taking account of look-ahead tokens as described by gcShadow()
  50.  * below.
  51.  *
  52.  * Of the non-terminals used below, only start, topDecl & begin do not leave
  53.  * any values on the Gofer stack.  The same is true for the terminals
  54.  * EVALEX and SCRIPT.  At the end of a successful parse, there should only
  55.  * be one element left on the stack, containing the result of the parse.
  56.  */
  57.  
  58. #define gc0(e)             gcShadow(0,e)
  59. #define gc1(e)             gcShadow(1,e)
  60. #define gc2(e)             gcShadow(2,e)
  61. #define gc3(e)             gcShadow(3,e)
  62. #define gc4(e)             gcShadow(4,e)
  63. #define gc5(e)             gcShadow(5,e)
  64. #define gc6(e)             gcShadow(6,e)
  65. #define gc7(e)             gcShadow(7,e)
  66.  
  67. %}
  68.  
  69. %token EVALEX    SCRIPT
  70. %token '='       COCO       INFIXL     INFIXR     INFIX      FUNARROW
  71. %token '-'       ','        '@'        '('        ')'        '|'
  72. %token ';'       UPTO       '['        ']'        CASEXP     OF
  73. %token IF        THEN       ELSE       WHERE      TYPE       DATA
  74. %token FROM      '\\'       '~'        LET        IN         '`'
  75. %token VAROP     VARID      NUMLIT     CHARLIT    STRINGLIT  REPEAT
  76. %token CONOP     CONID
  77. %token TCLASS    IMPLIES    TINSTANCE
  78. %token DO     END
  79. %token PRIMITIVE
  80.  
  81.                     /* Haskell keywords, for compatibility */
  82. %token DEFAULT     DERIVING   HIDING     IMPORT      INTERFACE  MODULE
  83. %token RENAMING  TO
  84.  
  85. %%
  86. /*- Top level script/module structure -------------------------------------*/
  87.  
  88. start      : EVALEX exp            {inputExpr = $2;        sp-=1;}
  89.       | EVALEX exp wherePart    {inputExpr = letrec($3,$2); sp-=2;}
  90.       | SCRIPT topModule        {valDefns  = $2;        sp-=1;}
  91.       | error            {syntaxError("input");}
  92.       ;
  93.  
  94. /*- Haskell module header/import parsing: ---------------------------------*/
  95. /*  Syntax for Haskell modules (module headers and imports) is parsed but  */
  96. /*  is otherwise ignored by Gofer.  This is for the benefit of those who   */
  97. /*  use Gofer to develop code which will ultimately be fed into a full       */
  98. /*  Haskell system.  (default and deriving are treated in a similar way.)  */
  99. /*                                       */
  100. /*  Note that we do not make any attempt to provide actions that store       */
  101. /*  the parsed structures in any way for later use.               */
  102. /*-------------------------------------------------------------------------*/
  103.  
  104. topModule : begin topDecls close    {$$ = gc2($2);}
  105.       | modules            {$$ = $1;}
  106.       ;
  107. begin      : error            {yyerrok; goOffside(startColumn);}
  108.       ;
  109. topDecls  : topDecls ';' topDecl    {$$ = gc2($1);}
  110.       | topDecls ';' decl        {$$ = gc3(cons($3,$1));}
  111.       | topDecl            {$$ = gc0(NIL);}
  112.       | decl            {$$ = gc1(cons($1,NIL));}
  113.       | error            {syntaxError("definition");}
  114.       ;
  115. modules      : modules module        {$$ = gc2(appendOnto($2,$1));}
  116.       | module            {$$ = $1;}
  117.       ;
  118. module      : MODULE modid expspec WHERE '{' topDecls close
  119.                     {$$ = gc7($6);}
  120.       | MODULE error        {syntaxError("module definition");}
  121.       ;
  122. topDecl      : IMPORT modid impspec rename    {sp-=4;}
  123.       | IMPORT error        {syntaxError("import declaration");}
  124.       ;
  125. modid      : CONID            {$$ = $1;}
  126.       | STRINGLIT            {$$ = $1;}
  127.       ;
  128. expspec      : /* empty */            {$$ = gc0(NIL);}
  129.       | '(' exports ')'        {$$ = gc3(NIL);}
  130.       ;
  131. exports      : exports ',' export        {$$ = gc3(NIL);}
  132.       | export            {$$ = $1;}
  133.       ;
  134. export      : entity            {$$ = $1;}
  135.       | modid UPTO            {$$ = gc2(NIL);}
  136.       ;
  137. impspec      : /* empty */            {$$ = gc0(NIL);}
  138.       | HIDING '(' imports ')'    {$$ = gc4(NIL);}
  139.       | '(' imports0 ')'        {$$ = gc3(NIL);}
  140.       ;
  141. imports0  : /* empty */            {$$ = gc0(NIL);}
  142.       | imports            {$$ = $1;}
  143.       ;
  144. imports      : imports ',' entity        {$$ = gc3(NIL);}
  145.       | entity            {$$ = $1;}
  146.       ;
  147. rename      : /* empty */            {$$ = gc0(NIL);}
  148.       | RENAMING '(' renamings ')'    {$$ = gc4(NIL);}
  149.       ;
  150. renamings : renamings ',' renaming    {$$ = gc3(NIL);}
  151.       | renaming            {$$ = $1;}
  152.       ;
  153. renaming  : var   TO var        {$$ = gc3(NIL);}
  154.       | conid TO conid        {$$ = gc3(NIL);}
  155.       ;
  156. entity      : var                {$$ = $1;}
  157.       | CONID            {$$ = $1;}
  158.       | CONID '(' UPTO ')'        {$$ = gc4(NIL);}
  159.       | CONID '(' conids ')'    {$$ = gc4(NIL);}
  160.       | CONID '(' vars0 ')'        {$$ = gc4(NIL);}
  161.       ;
  162. conids      : conids ',' conid        {$$ = gc3(NIL);}
  163.       | conid            {$$ = $1;}
  164.       ;
  165. vars0      : /* empty */            {$$ = gc0(NIL);}
  166.       | vars            {$$ = $1;}
  167.       ;
  168.  
  169. /*- Type declarations: ----------------------------------------------------*/
  170.  
  171. topDecl      : TYPE typeLhs '=' type invars{defTycon(5,$3,$2,$4,$5);}
  172.       | DATA typeLhs '=' constrs deriving        /* deriving is IGNORED */
  173.                     {defTycon(5,$3,$2,rev($4),DATATYPE);}
  174.       ;
  175. typeLhs      : typeLhs VARID        {$$ = gc2(ap($1,$2));}
  176.       | CONID            {$$ = $1;}
  177.       | error            {syntaxError("type defn lhs");}
  178.       ;
  179. invars      : IN rsvars            {$$ = gc2($2);}
  180.       | /* empty */            {$$ = gc0(SYNONYM);}
  181.       ;
  182. rsvars      : rsvars ',' rsvar        {$$ = gc3(cons($3,$1));}
  183.       | rsvar            {$$ = gc1(cons($1,NIL));}
  184.       ;
  185. rsvar      : var COCO sigType        {$$ = gc3(sigdecl($2,singleton($1),
  186.                                  $3));}
  187.       | var                {$$ = $1;}
  188.       ;
  189. constrs      : constrs '|' constr        {$$ = gc3(cons($3,$1));}
  190.       | constr            {$$ = gc1(cons($1,NIL));}
  191.       ;
  192. constr      : type CONOP type        {$$ = gc3(ap(ap($2,$1),$3));}
  193.       | type            {if (!isCon(getHead($1)))
  194.                          syntaxError("data constructor");
  195.                      $$ = $1;}
  196.       | error            {syntaxError("data type definition");}
  197.       ;
  198. deriving  : /* empty */            {$$ = gc0(NIL);}
  199.       | DERIVING CONID        {$$ = gc2(singleton($2));}
  200.       | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
  201.       ;
  202. derivs0   : /* empty */            {$$ = gc0(NIL);}
  203.       | derivs            {$$ = $1;}
  204.       ;
  205. derivs      : derivs ',' CONID        {$$ = gc3(cons($3,$1));}
  206.       | CONID            {$$ = gc1(singleton($1));}
  207.       ;
  208.  
  209. /*- Type expressions: -----------------------------------------------------*/
  210. /*  Parser is not sufficently powerful to distinguish between a predicate
  211.  *  such as "Dual a b" and a type "Sum a b", or between a tuple type and
  212.  *  a context (e.g. (Alpha a, Beta b) is a tuple or context?).  For this
  213.  *  reason, individual predicates and contexts are parsed as types, with
  214.  *  additional code to check for well formed context/classes.
  215.  */
  216.  
  217. sigType      : context IMPLIES type    {$$ = gc3(ap(QUAL,pair($1,$3)));}
  218.       | type            {$$ = $1;}
  219.       ;
  220. context      : type            {$$ = gc1(checkContext($1));}
  221.       ;
  222. type      : ctype            {$$ = $1;}
  223.       | ctype FUNARROW type        {$$ = gc3(ap(ap(ARROW,$1),$3));}
  224.       | error            {syntaxError("type expression");}
  225.       ;
  226. ctype      : ctype atype            {$$ = gc2(ap($1,$2));}
  227.       | atype            {$$ = $1;}
  228.       ;
  229. atype      : VARID            {$$ = $1;}
  230.       | CONID            {$$ = $1;}
  231.       | '(' ')'            {$$ = gc2(UNIT);}
  232.       | '(' FUNARROW ')'        {$$ = gc3(ARROW);}
  233.       | '(' type ')'        {$$ = gc3($2);}
  234.       | '(' tupCommas ')'        {$$ = gc3($2);}
  235.       | '(' typeTuple ')'        {$$ = gc3(buildTuple($2));}
  236.       | '[' type ']'        {$$ = gc3(ap(LIST,$2));}
  237.       | '[' ']'            {$$ = gc2(LIST);}
  238.       ;
  239. tupCommas : tupCommas ','        {$$ = gc3(mkTuple(tupleOf($1)+1));}
  240.       | ','                {$$ = gc1(mkTuple(2));}
  241.       ;
  242. typeTuple : typeTuple ',' type        {$$ = gc3(cons($3,$1));}
  243.       | type ',' type        {$$ = gc3(cons($3,cons($1,NIL)));}
  244.       ;
  245.  
  246. /*- Fixity declarations: --------------------------------------------------*/
  247.  
  248. topDecl      : INFIXL optdigit ops        {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
  249.       | INFIXR optdigit ops        {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
  250.       | INFIX  optdigit ops        {fixDefn(NON_ASS,$1,$2,$3);  sp-=3;}
  251.       ;
  252. optdigit  : NUMLIT            {$$ = gc1(checkPrec($1));}
  253.       | /* empty */            {$$ = gc0(mkInt(DEF_PREC));}
  254.       ;
  255. ops      : ops ',' op            {$$ = gc3(cons($3,$1));}
  256.       | op                {$$ = gc1(cons($1,NIL));}
  257.       ;
  258. op      : varop            {$$ = $1;}
  259.       | conop            {$$ = $1;}
  260.       | '-'                {$$ = gc1(varMinus);}
  261.       ;
  262. varop      : VAROP            {$$ = $1;}
  263.       | '`' VARID '`'        {$$ = gc3($2);}
  264.       ;
  265. conop      : CONOP            {$$ = $1;}
  266.       | '`' CONID '`'        {$$ = gc3($2);}
  267.       ;
  268.  
  269. /*- Processing definitions of primitives ----------------------------------*/
  270.  
  271. topDecl      : PRIMITIVE prims COCO type    {primDefn(intOf($1),$2,$4); sp-=4;}
  272.       ;
  273. prims      : prims ',' prim        {$$ = gc3(cons($3,$1));}
  274.       | prim            {$$ = gc1(cons($1,NIL));}
  275.       | error            {syntaxError("primitive defn");}
  276.       ;
  277. prim      : var STRINGLIT        {$$ = gc2(pair($1,$2));}
  278.       ;
  279.  
  280. /*- Class declarations: ---------------------------------------------------*/
  281.  
  282. topDecl      : TCLASS classHead classBody    {classDefn(intOf($1),$2,$3); sp-=3;}
  283.       | TINSTANCE classHead instBody{instDefn(intOf($1),$2,$3);  sp-=3;}
  284.       | DEFAULT type        {sp-=2;}    /* default is IGNORED  */
  285.       ;
  286. classHead : context IMPLIES type    {$$ = gc3(pair($1,checkClass($3)));}
  287.       | type            {$$ = gc1(pair(NIL,checkClass($1)));}
  288.       ;
  289. classBody : WHERE '{' csigdecls close    {$$ = gc4($3);}
  290.       | /* empty */            {$$ = gc0(NIL);}
  291.       ;
  292. instBody  : WHERE '{' decls close    {$$ = gc4($3);}
  293.       | /* empty */            {$$ = gc0(NIL);}
  294.       ;
  295. csigdecls : csigdecls ';' csigdecl    {$$ = gc3(cons($3,$1));}
  296.       | csigdecl            {$$ = gc1(cons($1,NIL));}
  297.       ;
  298. csigdecl  : vars COCO type        {$$ = gc3(sigdecl($2,$1,$3));}
  299.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  300.       ;
  301.  
  302. /*- Value declarations: ---------------------------------------------------*/
  303.  
  304. decl      : vars COCO sigType        {$$ = gc3(sigdecl($2,$1,$3));}
  305.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  306.       ;
  307. decls      : decls ';' decl        {$$ = gc3(cons($3,$1));}
  308.       | decl            {$$ = gc1(cons($1,NIL));}
  309.       ;
  310. rhs      : rhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  311.       | rhs1            {$$ = $1;}
  312.       | error            {syntaxError("declaration");}
  313.       ;
  314. rhs1      : '=' exp            {$$ = gc2(pair($1,$2));}
  315.       | gdefs            {$$ = gc1(grded(rev($1)));}
  316.       ;
  317. wherePart : WHERE '{' decls close    {$$ = gc4($3);}
  318.       ;
  319. gdefs      : gdefs gdef            {$$ = gc2(cons($2,$1));}
  320.       | gdef            {$$ = gc1(cons($1,NIL));}
  321.       ;
  322. gdef      : '|' exp '=' exp        {$$ = gc4(pair($3,pair($2,$4)));}
  323.       /* Experimental, undocumented syntax for Orwell style guards     */
  324.       /* The corresponding forms for case definitions are NOT supported*/
  325.       /* because that would require a change to the original syntax for*/
  326.           /* Gofer, rather than a simple extension as is the case here.    */
  327.       /* Perhaps a slight reworking of the grammar might eliminate this*/
  328.       /* problem...                               */
  329.       | '=' exp ',' IF exp        {$$ = gc5(pair($1,pair($5,$2)));}
  330.       | '=' exp ',' exp        {$$ = gc4(pair($1,pair($4,$2)));}
  331.       ;
  332. vars      : vars ',' var        {$$ = gc3(cons($3,$1));}
  333.       | var                {$$ = gc1(cons($1,NIL));}
  334.       ;
  335. var      : varid            {$$ = $1;}
  336.       | '(' '-' ')'            {$$ = gc3(varMinus);}
  337.       ;
  338. varid      : VARID            {$$ = $1;}
  339.       | '(' VAROP ')'        {$$ = gc3($2);}
  340.       ;
  341. conid      : CONID            {$$ = $1;}
  342.       | '(' CONOP ')'        {$$ = gc3($2);}
  343.       ;
  344.  
  345. /*- Expressions: ----------------------------------------------------------*/
  346.  
  347. exp      : opExp COCO sigType        {$$ = gc3(ap(ESIGN,pair($1,$3)));}
  348.       | opExp            {$$ = $1;}
  349.       | error            {syntaxError("expression");}
  350.       ; 
  351. opExp      : pfxExp            {$$ = $1;}
  352.       | pfxExp op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  353.       | opExp0            {$$ = gc1(tidyInfix($1));}
  354.       ;
  355. opExp0      : opExp0 op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  356.       | pfxExp op pfxExp op pfxExp    {$$ = gc5(ap(ap($4,
  357.                             ap(ap($2,singleton($1)),
  358.                                                            $3)),$5));}
  359.       ;
  360. pfxExp      : '-' appExp            {if (isInt($2))
  361.                          $$ = gc2(mkInt(-intOf($2)));
  362.                      else
  363.                          $$ = gc2(ap(varNegate,$2));
  364.                     }
  365.       | '\\' pats FUNARROW exp    {$$ = gc4(ap(LAMBDA,
  366.                              pair(rev($2),
  367.                                   pair($3,$4))));}
  368.       | LET '{' decls close IN exp    {$$ = gc6(letrec($3,$6));}
  369.       | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
  370.       | CASEXP exp OF '{' alts close{$$ = gc6(ap(CASE,pair($2,rev($5))));}
  371.       | appExp            {$$ = $1;}
  372.       ;
  373. pats      : pats atomic            {$$ = gc2(cons($2,$1));}
  374.       | atomic            {$$ = gc1(cons($1,NIL));}
  375.       ;
  376. appExp      : appExp atomic        {$$ = gc2(ap($1,$2));}
  377.       | atomic            {$$ = $1;}
  378.       ;
  379. atomic      : var                {$$ = $1;}
  380.       | var '@' atomic        {$$ = gc3(ap(ASPAT,pair($1,$3)));}
  381.       | '~' atomic            {$$ = gc2(ap(LAZYPAT,$2));}
  382.       | '_'                {$$ = gc1(WILDCARD);}
  383.       | conid            {$$ = $1;}
  384.       | '(' ')'            {$$ = gc2(UNIT);}
  385.       | NUMLIT            {$$ = $1;}
  386.       | CHARLIT            {$$ = $1;}
  387.       | STRINGLIT            {$$ = $1;}
  388.       | REPEAT            {$$ = $1;}
  389.       | '(' exp ')'            {$$ = gc3($2);}
  390.       | '(' exps2 ')'        {$$ = gc3(buildTuple($2));}
  391.       | '[' list ']'        {$$ = gc3($2);}
  392.       | '(' pfxExp op ')'        {$$ = gc4(ap($3,$2));}
  393.       | '(' varop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  394.       | '(' conop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  395.       ;
  396. exps2      : exps2 ',' exp        {$$ = gc3(cons($3,$1));}
  397.       | exp ',' exp            {$$ = gc3(cons($3,cons($1,NIL)));}
  398.       ;
  399. alts      : alts ';' alt        {$$ = gc3(cons($3,$1));}
  400.       | alt                {$$ = gc1(cons($1,NIL));}
  401.       ;
  402. alt      : opExp altRhs        {$$ = gc2(pair($1,$2));}
  403.       ;
  404. altRhs      : altRhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  405.       | altRhs1            {$$ = $1;}
  406.       ;
  407. altRhs1      : guardAlts            {$$ = gc1(grded(rev($1)));}
  408.       | FUNARROW exp        {$$ = gc2(pair($1,$2));}
  409.       | error            {syntaxError("case expression");}
  410.       ;
  411. guardAlts : guardAlts guardAlt        {$$ = gc2(cons($2,$1));}
  412.       | guardAlt            {$$ = gc1(cons($1,NIL));}
  413.       ;
  414. guardAlt  : '|' opExp FUNARROW exp    {$$ = gc4(pair($3,pair($2,$4)));}
  415.       ;
  416.  
  417. /*- List Expressions: -------------------------------------------------------*/
  418.  
  419. list      : /* empty */            {$$ = gc0(nameNil);}
  420.       | exp                {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
  421.       | exps2            {$$ = gc1(ap(FINLIST,rev($1)));}
  422.       | exp '|' quals        {$$ = gc3(ap(COMP,pair($1,rev($3))));}
  423.       | exp         UPTO exp    {$$ = gc3(ap(ap(varFromTo,$1),$3));}
  424.       | exp ',' exp UPTO        {$$ = gc4(ap(ap(varFromThen,$1),$3));}
  425.       | exp         UPTO        {$$ = gc2(ap(varFrom,$1));}
  426.       | exp ',' exp UPTO exp    {$$ = gc5(ap(ap(ap(varFromThenTo,
  427.                                                                $1),$3),$5));}
  428.       ;
  429. quals      : quals ',' qual        {$$ = gc3(cons($3,$1));}
  430.       | qual            {$$ = gc1(cons($1,NIL));}
  431.       ;
  432. qual      : exp FROM exp        {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  433.       | exp '=' exp            {$$ = gc3(ap(QWHERE,
  434.                              singleton(
  435.                             pair($1,pair($2,
  436.                                      $3)))));}
  437.       | exp                {$$ = gc1(ap(BOOLQUAL,$1));}
  438.       | LET '{' decls close        {$$ = gc4(ap(QWHERE,$3));}
  439.       ;
  440.  
  441. /*- Do syntax for monad comprehensions: -------------------------------------*/
  442. /* Motivated by suggestions from Bernard Sufrin, I have been toying with the
  443.  * use of an alternative syntax for monad comprehensions, based on the syntax:
  444.  *                        do { dquals } in expr
  445.  * as an alternative to [ exp | quals ].  For one thing, this allows us
  446.  * to use layout rather than explicit punctuation to separate qualifiers.
  447.  * I also took the liberty of experimenting with different qualifier
  448.  * syntax.  In particular, a simple `exp' in the standard comprehension
  449.  * notation is used for a boolean guard.  Here, it is used as an abbreviation
  450.  * for the generator _ <- exp.  This makes `imperative programming' in a monad
  451.  * look quite nice:
  452.  *
  453.  *       do v <- newVar                  do
  454.  *          assign v 1                      e1 <- expr
  455.  *          puts "Hello, world"             token "+"
  456.  *          x <- deref v                    e2 <- expr
  457.  *          puts (show x)                in
  458.  *       end                                e1 + e2
  459.  *
  460.  * (The keyword `end' has also be introduced as a prettier way to write
  461.  * `in()'.)  Exact details of syntax can be gleaned from the yacc grammar
  462.  * below.
  463.  *
  464.  * I've played with this notation a little, and I think it has some rather
  465.  * nice features.  On the other hand, I decided not to burden every Gofer
  466.  * user with this `experimental extension' ... The only parts of the system
  467.  * that need to be changed to accomodate the new syntax are in the input
  468.  * routines.  If you want to play with this extension, look for each
  469.  * occurrence of the symbol DO_COMPS in parser.y and input.c (there are
  470.  * three mentions in each file, excluding the reference in this comment
  471.  * itself).  Remove the comments from those sections of code, recompile and
  472.  * try it out.  Please let me know how you get on ... I'd be interested to
  473.  * hear other people's opinions on this.
  474.  *
  475.  * Mark
  476.  */
  477.  
  478. pfxExp      : DO '{' dquals close IN exp    {$$ = gc6(ap(COMP,pair($6,rev($3))));}
  479.       | DO '{' dquals close END    {$$ = gc5(ap(COMP,pair(UNIT,rev($3))));}
  480.       ;
  481. dquals      : dquals ';' dqual        {$$ = gc3(cons($3,$1));}
  482.       | dqual            {$$ = gc1(cons($1,NIL));}
  483.       ;
  484. dqual      : exp FROM exp        {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  485.       | exp                {$$ = gc1(ap(FROMQUAL,
  486.                              pair(WILDCARD,$1)));}
  487.       | IF exp            {$$ = gc2(ap(BOOLQUAL,$2));}
  488.       | LET '{' decls close        {$$ = gc4(ap(QWHERE,$3));}
  489.       ;
  490.  
  491. /*- Find closing brace ----------------------------------------------------*/
  492.  
  493.                     /* deal with trailing semicolon    */
  494. close      : ';' close1            {$$ = gc2($2);}
  495.       | close1            {$$ = $1;}
  496.       ;
  497. close1      : '}'                {$$ = $1;}
  498.       | error            {yyerrok;
  499.                                          if (canUnOffside()) {
  500.                                              unOffside();
  501.                          /* insert extra token on stack*/
  502.                          push(NIL);
  503.                          pushed(0) = pushed(1);
  504.                          pushed(1) = mkInt(column);
  505.                      }
  506.                                          else
  507.                                              syntaxError("definition");
  508.                                         }
  509.       ;
  510.  
  511. /*-------------------------------------------------------------------------*/
  512.  
  513. %%
  514.  
  515. static Cell local gcShadow(n,e)        /* keep parsed fragments on stack  */
  516. Int  n;
  517. Cell e; {
  518.     /* If a look ahead token is held then the required stack transformation
  519.      * is:
  520.      *   pushed: n               1     0          1     0
  521.      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
  522.      *                                top()            top()
  523.      *
  524.      * Othwerwise, the transformation is:
  525.      *   pushed: n-1             0        0
  526.      *           x1  |  ...  |  xn  ===>  e
  527.      *                         top()     top()
  528.      */
  529.     if (yychar>=0) {
  530.     pushed(n-1) = top();
  531.         pushed(n)   = e;
  532.     }
  533.     else
  534.     pushed(n-1) = e;
  535.     sp -= (n-1);
  536.     return e;
  537. }
  538.  
  539. static Void local syntaxError(s)       /* report on syntax error           */
  540. String s; {
  541.     ERROR(row) "Syntax error in %s (unexpected %s)", s, unexpected()
  542.     EEND;
  543. }
  544.  
  545. static String local unexpected() {    /* find name for unexpected token  */
  546.     static char buffer[100];
  547.     static char *fmt = "%s \"%s\"";
  548.     static char *kwd = "keyword";
  549.     static char *hkw = "(Haskell) keyword";
  550.  
  551.     switch (yychar) {
  552.     case 0           : return "end of input";
  553.  
  554. #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
  555.     case INFIXL    : keyword("infixl");
  556.     case INFIXR    : keyword("infixr");
  557.     case INFIX     : keyword("infix");
  558.     case TINSTANCE : keyword("instance");
  559.     case TCLASS    : keyword("class");
  560.     case PRIMITIVE : keyword("primitive");
  561.     case CASEXP    : keyword("case");
  562.     case OF        : keyword("of");
  563.     case DO        : keyword("do");
  564.     case END       : keyword("end");
  565.     case IF        : keyword("if");
  566.     case THEN      : keyword("then");
  567.     case ELSE      : keyword("else");
  568.     case WHERE     : keyword("where");
  569.     case TYPE      : keyword("type");
  570.     case DATA      : keyword("data");
  571.     case LET       : keyword("let");
  572.     case IN        : keyword("in");
  573. #undef keyword
  574.  
  575. #define hasword(kw) sprintf(buffer,fmt,hkw,kw); return buffer;
  576.     case DEFAULT   : hasword("default");
  577.     case DERIVING  : hasword("deriving");
  578.     case HIDING    : hasword("hiding");
  579.     case IMPORT    : hasword("import");
  580.     case INTERFACE : hasword("interface");
  581.     case MODULE    : hasword("module");
  582.     case RENAMING  : hasword("renaming");
  583.     case TO           : hasword("to");
  584. #undef hasword
  585.  
  586.     case FUNARROW  : return "`->'";
  587.     case '='       : return "`='";
  588.     case COCO      : return "`::'";
  589.     case '-'       : return "`-'";
  590.     case ','       : return "comma";
  591.     case '@'       : return "`@'";
  592.     case '('       : return "`('";
  593.     case ')'       : return "`)'";
  594.     case '|'       : return "`|'";
  595.     case ';'       : return "`;'";
  596.     case UPTO      : return "`..'";
  597.     case '['       : return "`['";
  598.     case ']'       : return "`]'";
  599.     case FROM      : return "`<-'";
  600.     case '\\'      : return "backslash (lambda)";
  601.     case '~'       : return "tilde";
  602.     case '`'       : return "backquote";
  603.     case VAROP     :
  604.     case VARID     :
  605.     case CONOP     :
  606.     case CONID     : sprintf(buffer,"symbol \"%s\"",
  607.                  textToStr(textOf(yylval)));
  608.              return buffer;
  609.     case NUMLIT    : return "numeric literal";
  610.     case CHARLIT   : return "character literal";
  611.     case STRINGLIT : return "string literal";
  612.     case IMPLIES   : return "`=>";
  613.     default           : return "token";
  614.     }
  615. }
  616.  
  617. static Cell local checkPrec(p)         /* Check for valid precedence value */
  618. Cell p; {
  619.     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
  620.         ERROR(row) "Precedence value must be an integer in the range [%d..%d]",
  621.                    MIN_PREC, MAX_PREC
  622.         EEND;
  623.     }
  624.     return p;
  625. }
  626.  
  627. static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators      */
  628. Syntax a;
  629. Cell   line;
  630. Cell   p;
  631. List   ops; {
  632.     Int l = intOf(line);
  633.     a     = mkSyntax(a,intOf(p));
  634.     map2Proc(setSyntax,l,a,ops);
  635. }
  636.  
  637. static Void local setSyntax(line,sy,op)/* set syntax of individ. operator  */
  638. Int    line;
  639. Syntax sy;
  640. Cell   op; {
  641.     addSyntax(line,textOf(op),sy);
  642.     opDefns = cons(op,opDefns);
  643. }
  644.  
  645. #if MAC
  646.        Cell local buildTuple(tup) 
  647. #else
  648. static Cell local buildTuple(tup)      /* build tuple (x1,...,xn) from list*/
  649. #endif
  650. List tup; {                            /* [xn,...,x1]                      */
  651.     Int  n = 0;
  652.     Cell t = tup;
  653.     Cell x;
  654.  
  655.     do {                               /*     .                    .       */
  656.         x      = fst(t);               /*    / \                  / \      */
  657.         fst(t) = snd(t);               /*   xn  .                .   xn    */
  658.         snd(t) = x;                    /*        .    ===>      .          */
  659.         x      = t;                    /*         .            .           */
  660.         t      = fun(x);               /*          .          .            */
  661.         n++;                           /*         / \        / \           */
  662.     } while (nonNull(t));              /*        x1  NIL   (n)  x1         */
  663.     fst(x) = mkTuple(n);
  664.     return tup;
  665. }
  666.  
  667. /* The yacc parser presented above is not sufficiently powerful to
  668.  * determine whether a tuple at the front of a sigType is part of a
  669.  * context:    e.g. (Eq a, Num a) => a -> a -> a
  670.  * or a type:  e.g.  (Tree a, Tree a) -> Tree a
  671.  *
  672.  * Rather than complicate the grammar, both are parsed as tuples of types,
  673.  * using the following checks afterwards to ensure that the correct syntax
  674.  * is used in the case of a tupled context.
  675.  */
  676.  
  677. static List local checkContext(con)    /* validate type class context       */
  678. Type con; {
  679.     if (con==UNIT)            /* allows empty context ()       */
  680.     return NIL;
  681.     else if (whatIs(getHead(con))==TUPLE) {
  682.     List qs = NIL;
  683.  
  684.     while (isAp(con)) {        /* undo work of buildTuple  :-(    */
  685.         Cell temp = fun(con);
  686.         fun(con)  = arg(con);
  687.         arg(con)  = qs;
  688.         qs          = con;
  689.         con       = temp;
  690.         checkClass(hd(qs));
  691.     }
  692.     return qs;
  693.     }
  694.     else                /* single context expression       */
  695.     return singleton(checkClass(con));
  696. }
  697.  
  698. static Cell local checkClass(c)        /* check that type expr is a class */
  699. Cell c; {                /* constrnt of the form C t1 .. tn */
  700.     Cell cn = getHead(c);
  701.  
  702.     if (!isCon(cn))
  703.     syntaxError("class expression");
  704.     else if (argCount<1) {
  705.     ERROR(row) "Class \"%s\" must have at least one argument",
  706.            textToStr(textOf(cn))
  707.     EEND;
  708.     }
  709.     return c;
  710. }
  711.  
  712. /* expressions involving a sequence of two or more infix operator symbols
  713.  * are parsed as elements of type:
  714.  *    InfixExpr ::= [Expr]
  715.  *         |  ap(ap(Operator,InfixExpr),Expr)
  716.  *
  717.  * thus x0 +1 x1 ... +n xn is parsed as: +n (....(+1 [x0] x1)....) xn
  718.  *
  719.  * Once the expression has been completely parsed, this parsed form is
  720.  * `tidied' according to the precedences and associativities declared for
  721.  * each operator symbol.
  722.  *
  723.  * The tidy process uses a `stack' of type:
  724.  *    TidyStack ::= ap(ap(Operator,TidyStack),Expr)
  725.  *         |  NIL
  726.  * when the ith layer of an InfixExpr has been transferred to the stack, the
  727.  * stack is of the form: +i (....(+n NIL xn)....) xi
  728.  *
  729.  * The tidy function is based on a simple shift-reduce parser:
  730.  *
  731.  *  tidy                :: InfixExpr -> TidyStack -> Expr
  732.  *  tidy [m]   ss        = foldl (\x f-> f x) m ss
  733.  *  tidy (m*n) []        = tidy m [(*n)]
  734.  *  tidy (m*n) ((+o):ss)
  735.  *           | amb     = error "Ambiguous"
  736.  *           | shift   = tidy m ((*n):(+o):ss)
  737.  *           | reduce  = tidy (m*(n+o)) ss
  738.  *               where sye     = syntaxOf (*)
  739.  *                 (ae,pe) = sye
  740.  *                 sys     = syntaxOf (+)
  741.  *                 (as,ps) = sys
  742.  *                 amb     = pe==ps && (ae/=as || ae==NON_ASS)
  743.  *                 shift   = pe>ps || (ps==pe && ae==LEFT_ASS)
  744.  *                 reduce  = otherwise
  745.  *
  746.  * N.B. the conditions amb, shift, reduce are NOT mutually exclusive and
  747.  * must be tested in that order.
  748.  *
  749.  * As a concession to efficiency, we lower the number of calls to syntaxOf
  750.  * by keeping track of the values of sye, sys throughout the process.  The
  751.  * value APPLIC is used to indicate that the syntax value is unknown.
  752.  */
  753.  
  754. static Cell local tidyInfix(e)         /* convert InfixExpr to Expr        */
  755. Cell e; {                              /* :: InfixExpr                     */
  756.     Cell   s   = NIL;                  /* :: TidyStack                     */
  757.     Syntax sye = APPLIC;               /* Syntax of op in e (init unknown) */
  758.     Syntax sys = APPLIC;               /* Syntax of op in s (init unknown) */
  759.     Cell   temp;
  760.  
  761.     while (nonNull(tl(e))) {
  762.         if (isNull(s)) {
  763.             s           = e;
  764.             e           = arg(fun(s));
  765.             arg(fun(s)) = NIL;
  766.             sys         = sye;
  767.             sye         = APPLIC;
  768.         }
  769.         else {
  770.             if (sye==APPLIC) {         /* calculate sye (if unknown)       */
  771.                 sye = syntaxOf(textOf(fun(fun(e))));
  772.                 if (sye==APPLIC) sye=DEF_OPSYNTAX;
  773.             }
  774.             if (sys==APPLIC) {         /* calculate sys (if unknown)       */
  775.                 sys = syntaxOf(textOf(fun(fun(s))));
  776.                 if (sys==APPLIC) sys=DEF_OPSYNTAX;
  777.             }
  778.  
  779.             if (precOf(sye)==precOf(sys) &&                      /* amb    */
  780.                    (assocOf(sye)!=assocOf(sys) || assocOf(sye)==NON_ASS)) {
  781.                 ERROR(row) "Ambiguous use of operator \"%s\" with \"%s\"",
  782.                            textToStr(textOf(fun(fun(e)))),
  783.                            textToStr(textOf(fun(fun(s))))
  784.                 EEND;
  785.             }
  786.             else if (precOf(sye)>precOf(sys) ||                  /* shift  */
  787.                        (precOf(sye)==precOf(sys) && assocOf(sye)==LEFT_ASS)) {
  788.                 temp        = arg(fun(e));
  789.                 arg(fun(e)) = s;
  790.                 s           = e;
  791.                 e           = temp;
  792.                 sys         = sye;
  793.                 sye         = APPLIC;
  794.             }
  795.             else {                                               /* reduce */
  796.                 temp        = arg(fun(s));
  797.                 arg(fun(s)) = arg(e);
  798.                 arg(e)      = s;
  799.                 s           = temp;
  800.                 sys         = APPLIC;
  801.                 /* sye unchanged */
  802.             }
  803.         }
  804.     }
  805.  
  806.     e = hd(e);
  807.     while (nonNull(s)) {
  808.         temp        = arg(fun(s));
  809.         arg(fun(s)) = e;
  810.         e           = s;
  811.         s           = temp;
  812.     }
  813.  
  814.     return e;
  815. }
  816.  
  817. /*-------------------------------------------------------------------------*/
  818.  
  819.